home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / freefnt.com / FFDEMO55.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-01-19  |  8.0 KB  |  381 lines
  1. USES CRT,GRAPH,FFONT55;
  2.  
  3. VAR driver,mode : integer;
  4.      FontBuffer : array[0..20000] of byte;
  5.              TF : FontObj;
  6.  
  7. FUNCTION LoadFont(FN:string):boolean;
  8. VAR f : file;
  9.     r : word;
  10. BEGIN
  11.   {$I-}
  12.   ASSIGN(f,FN);
  13.   RESET(f,1);
  14.   BLOCKREAD(f,FontBuffer,sizeof(fontbuffer),r);
  15.   CLOSE(f);
  16.   LoadFont := (IOResult = 0) and (r>0);
  17.   {$I+}
  18. END;
  19.  
  20. PROCEDURE InitGraphics;
  21. VAR C : integer;
  22. BEGIN
  23.   Driver := detect;
  24.   INITGRAPH(Driver, Mode, '');
  25. {  SetGraphMode(1);}
  26.   IF GraphResult <> 0 THEN HALT(1);
  27. END;
  28.  
  29. PROCEDURE ClearScreen(c:integer);
  30. BEGIN
  31.   SETFILLSTYLE(SOLIDFILL,c);
  32.   BAR(0,0,GETMAXX,GETMAXY);
  33. END;
  34.  
  35. PROCEDURE CircleText( cx,cy,r,Align,GuideColor,dir:integer;
  36.                           st:string;
  37.                           StartA : real);
  38. VAR
  39.   tColor,c,circ,slen : integer;
  40.  TotalR,NextRotation,
  41.       cRotation,oldR : real;
  42.                   AC : ArcCoordsType;
  43.                    S : string;
  44.           CClockwise : boolean;
  45.  
  46. BEGIN
  47.   CClockwise := (dir < 0);
  48.   slen := TF.TextWidth(St);
  49.   circ := TRUNC(2*PI*r);
  50.   TotalR := slen/circ*360;
  51.   TColor := GetColor;
  52.  
  53.   SETTEXTJUSTIFY(LEFTTEXT,align);
  54.   TF.SetTextOptions(0,TRUE);
  55.  
  56.  
  57.   cRotation := StartA;
  58.  
  59.   FOR c := 1 to LENGTH(st) DO
  60.   BEGIN
  61.  
  62.     S := st[c];
  63.  
  64.     oldR := cRotation;
  65.  
  66.     NextRotation := (TF.TextWidth(S)/slen*TotalR);
  67.  
  68.     IF CClockwise
  69.     THEN BEGIN
  70.            cRotation := cRotation + NextRotation;
  71.            SETCOLOR(GuideColor);
  72.  
  73.            ARC(cx,cy,TRUNC(OldR),TRUNC(crotation),r);
  74.  
  75.            GETARCCOORDS(AC);
  76.  
  77.            SETCOLOR(tColor);
  78.  
  79.            WITH AC DO
  80.            BEGIN
  81.  
  82.              TF.SetRotation(OldR + NextRotation/2 + 90);
  83.  
  84.              TF.StringOutxy(xStart,yStart,S);
  85.  
  86.            END;
  87.          END
  88.     ELSE BEGIN
  89.            cRotation := cRotation - NextRotation;
  90.            SETCOLOR(GuideColor);
  91.  
  92.            ARC(cx,cy,TRUNC(crotation),TRUNC(OldR),r);
  93.  
  94.            GETARCCOORDS(AC);
  95.  
  96.            SETCOLOR(tColor);
  97.  
  98.            WITH AC DO
  99.            BEGIN
  100.  
  101.              TF.SetRotation(OldR - NextRotation/2 +270);
  102.  
  103.              TF.StringOutxy(xend,yend,S);
  104.  
  105.            END;
  106.          END
  107.   END;
  108. END;
  109.  
  110. PROCEDURE ShadowDemo;
  111. VAR atX,atY : integer;
  112. BEGIN
  113.   atX := GETMAXX div 2;
  114.   atY := GETMAXY div 2;
  115.  
  116.   SETTEXTJUSTIFY(CENTERTEXT,CENTERTEXT);
  117.  
  118.   TF.SetTextStyle(@FontBuffer,-30,8);
  119.  
  120.   SETCOLOR(BLUE);
  121.   TF.SetTextOptions(-30,TRUE);
  122.   TF.StringOutXY(atX ,atY ,'''FreeFont'' 3-D Text');
  123.  
  124.   SETCOLOR(WHITE);
  125.   TF.SetTextOptions(30,TRUE);
  126.   TF.StringOutXY(atX ,atY ,'''FreeFont'' 3-D Text');
  127.  
  128. END;
  129.  
  130. PROCEDURE Mirrordemo;
  131. BEGIN
  132.   SETFILLSTYLE(SOLIDFILL,BLUE);
  133.   BAR(0,0,GETMAXX,GETMAXY div 2);
  134.  
  135.   SETFILLSTYLE(SOLIDFILL,LIGHTBLUE);
  136.   BAR(0,GETMAXY div 2,GETMAXX,GETMAXY);
  137.  
  138.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  139.   TF.SetTextStyle(@FontBuffer,0,7);
  140.  
  141.   TF.SetTextOptions(-15,TRUE);
  142.   SETCOLOR(WHITE);
  143.   TF.StringOutXY(GETMAXX div 2,(GETMAXY div 2) - 2,'''FreeFont'' Mirror');
  144.  
  145.   TF.SetTextOptions(195,TRUE);
  146.   SETCOLOR(lightGray);
  147.   TF.StringOutXY(GETMAXX div 2,(GETMAXY div 2)+2,'''FreeFont'' Mirror');
  148.  
  149. END;
  150.  
  151. PROCEDURE CircDemoII;
  152. VAR
  153.              Xasp,Yasp : word;
  154.     atX,atY,rad,bColor : integer;
  155.  
  156. BEGIN
  157.   bcolor := LIGHTBLUE;
  158.   GETASPECTRATIO(Xasp,Yasp);
  159.   atX := GETMAXX div 2;
  160.   atY := GETMAXY div 2;
  161.   rad := 140;
  162.  
  163.   SETCOLOR(bColor);
  164.  
  165.   SETFILLSTYLE(SOLIDFILL,BLUE);
  166.   FILLELLIPSE(atX,atY,(rad-5),(rad-5) * longint(Xasp) div Yasp);
  167.  
  168.   TF.SetTextStyle(@FontBuffer,0,14);
  169.   TF.SetTextOptions(0,TRUE);
  170.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  171.   TF.StringOutXY(atX,atY,'II');
  172.   TF.SetTextStyle(@FontBuffer,0,7);
  173.  
  174.  
  175.   SETCOLOR(BLACK);
  176.   CircleText(atX,atY,rad,TOPTEXT,bColor,-1,'''FreeFont'' Circular Text',180);
  177. END;
  178.  
  179. PROCEDURE CircDemoI;
  180. VAR
  181.              Xasp,Yasp : word;
  182.     atX,atY,rad,bColor : integer;
  183. BEGIN
  184.   bColor := LIGHTBLUE;
  185.   GETASPECTRATIO(Xasp,Yasp);
  186.   atX := GETMAXX div 2;
  187.   atY := GETMAXY div 2;
  188.   rad := 140;
  189.  
  190.   SETCOLOR(bColor);
  191.  
  192.   SETFILLSTYLE(SOLIDFILL,BLUE);
  193.   FILLELLIPSE(atX,atY,rad-10,(rad-10) * longint(Xasp) div Yasp);
  194.  
  195.   TF.SetTextStyle(@FontBuffer,0,14);
  196.   TF.SetTextOptions(0,TRUE);
  197.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  198.   TF.StringOutXY(atX,atY,'I');
  199.  
  200.   TF.SetTextStyle(@FontBuffer,0,7);
  201.   SETCOLOR(WHITE);
  202.   CircleText(atX,atY,rad,BOTTOMTEXT,bcolor,1,'''FreeFont'' Circular Text',0);
  203. END;
  204.  
  205. PROCEDURE RotateDemo;
  206. BEGIN
  207.   SETTEXTJUSTIFY(LEFTTEXT,BOTTOMTEXT);
  208.  
  209.   TF.SetTextStyle(@FontBuffer,90,8);
  210.   TF.SetTextOptions(0,TRUE);
  211.  
  212.   SETCOLOR(BLACK);
  213.   TF.StringOutXY(60,GETMAXY - 20,'Rotate Text');
  214.  
  215.   SETCOLOR(DarkGray);
  216.   TF.SetRotation(60);
  217.   TF.StringOutXY(60,GETMAXY - 20,'Rotate Text');
  218.  
  219.   SETCOLOR(LightGray);
  220.   TF.SetRotation(30);
  221.   TF.StringOutXY(60,GETMAXY - 20,'Rotate Text');
  222.  
  223.   SETCOLOR(WHITE);
  224.   TF.SetRotation(0);
  225.   TF.StringOutXY(60,GETMAXY - 20,'Rotate Text');
  226.  
  227. END;
  228.  
  229. PROCEDURE LastPage;
  230. VAR atX,atY : integer;
  231. BEGIN
  232.   IF LoadFont('LITT.chr') THEN
  233.   BEGIN
  234.  
  235.  
  236.   TF.SetTextStyle(@FontBuffer,0,8);
  237.   TF.SetTextOptions(0,FALSE);
  238.  
  239.   SETCOLOR(BLACK);
  240.   SETTEXTJUSTIFY(LEFTTEXT,TOPTEXT);
  241.   atX := 40;
  242.   atY := 10;
  243.   TF.StringOutXY(atX,atY,'''FreeFont'' is a Turbo Pascal Unit for v5.0 and v5.5');
  244.   INC(atY,30);
  245.   TF.StringOutXY(atX,atY,'of Borland''s Turbo Pascal Compiler.  Source code is');
  246.   INC(atY,30);
  247.   TF.StringOutXY(atX,atY,'available by sending $10.00 to :');
  248.   INC(atY,45);
  249.   TF.StringOutXY(atX,atY,'Michael E. Garey');
  250.   INC(atY,30);
  251.   TF.StringOutXY(atX,atY,'912 Blue Mountain Ln.');
  252.   INC(atY,30);
  253.   TF.StringOutXY(atX,atY,'Antioch, TN 37013');
  254.   INC(atY,45);
  255.   TF.StringOutXY(atX,atY,'Please specify a 3.5" or 5.25" diskette.');
  256.   END;
  257. END;
  258.  
  259. PROCEDURE FeatureDemo;
  260. BEGIN
  261.   SETTEXTJUSTIFY(LEFTTEXT,TOPTEXT);
  262.  
  263.   TF.SetTextStyle(@FontBuffer,0,6);
  264.   SETCOLOR(BLACK);
  265.  
  266.   TF.SetTextOptions(0,FALSE);
  267.   TF.StringOutXY(30,20,'''FreeFont'' text can be');
  268.  
  269.   TF.SetTextOptions(-15,FALSE);
  270.   TF.StringOutXY(30,60,'Italics');
  271.  
  272.   TF.SetTextOptions(0,TRUE);
  273.   TF.StringOutXY(30,100,'Bold');
  274.  
  275.   TF.SetTextOptions(-15,TRUE);
  276.   TF.StringOutXY(30,140,'or BOTH');
  277. END;
  278.  
  279. PROCEDURE welcome;
  280. BEGIN
  281.   TF.SetTextStyle(@FontBuffer,0,14);
  282.   TF.SetTextOptions(0,TRUE);
  283.   SETCOLOR(YELLOW);
  284.   CircleText(GETMAXX div 2,GETMAXY + GETMAXY div 8,480,TOPTEXT,LIGHTBLUE,1,'Welcome',117);
  285.   CircleText(GETMAXX div 2,GETMAXY div -8,480,BOTTOMTEXT,LIGHTBLUE,-1,'''FreeFont''',239);
  286.   TF.SetTextStyle(@FontBuffer,0,7);
  287.   TF.SetTextOptions(0,TRUE);
  288.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  289.   TF.StringOutXY(GETMAXX div 2 ,GETMAXY div 2,'to');
  290.  
  291. END;
  292.  
  293. FUNCTION Finished:boolean;
  294. VAR
  295.       ch : Char;
  296.        d : longint;
  297.     done : boolean;
  298. BEGIN
  299.   d := 0;
  300.   done := FALSE;
  301.   SETCOLOR(WHITE);
  302.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  303.   OUTTEXTXY(GETMAXX div 2,GETMAXY - 5,'Press any key to QUIT');
  304.   REPEAT
  305.     IF KEYPRESSED THEN
  306.     BEGIN
  307.       ch := readkey;
  308.       IF ch = #0 THEN ch := readkey;
  309.       done := TRUE;
  310.     END ELSE INC(d);
  311.   UNTIL done or (d=400000);
  312.   Finished := done;
  313. END;
  314.  
  315. PROCEDURE continue;
  316. VAR
  317.       ch : Char;
  318.        d : longint;
  319.     done : boolean;
  320. BEGIN
  321.   d := 0;
  322.   done := FALSE;
  323.   SETCOLOR(WHITE);
  324.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  325.   OUTTEXTXY(GETMAXX div 2,GETMAXY - 5,'Press any key to continue');
  326.   REPEAT
  327.     IF KEYPRESSED THEN
  328.     BEGIN
  329.       ch := readkey;
  330.       IF ch = #0 THEN ch := readkey;
  331.       Done := TRUE;
  332.     END ELSE INC(d);
  333.   UNTIL done or (d=100000);
  334.   ClearScreen(LIGHTBLUE);
  335. END;
  336.  
  337. BEGIN
  338.   InitGraphics;
  339.  
  340.   IF LoadFont('trip.chr') THEN
  341.   BEGIN
  342.  
  343.     REPEAT
  344.  
  345.       ClearScreen(LIGHTBLUE);
  346.  
  347.       Welcome;
  348.       continue;
  349.  
  350.       FeatureDemo;
  351.       continue;
  352.  
  353.       RotateDemo;
  354.       continue;
  355.  
  356.       CircDemoI;
  357.       continue;
  358.  
  359.       CircDemoII;
  360.       continue;
  361.  
  362.       MirrorDemo;
  363.       continue;
  364.  
  365.       ShadowDemo;
  366.       continue;
  367.  
  368.       LastPage;
  369.  
  370.     UNTIL finished;
  371.  
  372.     restorecrtmode;
  373.  
  374.   END
  375.   ELSE BEGIN
  376.          restorecrtmode;
  377.          writeln('Error Loading the Font File.');
  378.        END;
  379. END.
  380.  
  381.